Attribute VB_Name = "ExcelBricks"
' version 7.7
'   Supports ExcelBricks API      v6.2+   (for calling sRunProgram)
'   Supports ExcelBricks Syntax   v7.7+   (for configuration sheet)
' Copyright 2011 potato.peelings@gmail.com



' Windows API function declarations
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetTempPathA Lib "kernel32" _
   (ByVal nBufferLength As Long, _
    ByVal lpBuffer As String) As Long
Private Declare Function GetTempFileNameA Lib "kernel32" _
    (ByVal lpszPath As String, ByVal lpPrefixString As String, _
     ByVal wUnique As Long, ByVal lpTempFileName As String) _
     As Long

' configuration sheet columns
Const colCommand As Integer = 1
Const colParameter1 As Integer = 2
Const colParameter2 As Integer = 3
Const colParameter3 As Integer = 4

' global private values
Private tmStartTime As Date                         ' time clock was first started
Private tmStopClockTime As Date                     ' time clock was "last" stopped
Private intCommandRow As Integer                    ' current row being processed
Private strStatusLog As String                      ' status log
Private boolNoScreenRefresh As Boolean              ' turn off screen updates?

' handled errors - set to public for external access
Public Const lngFullError As Long = 7000            ' shows standard log and critical error
Public Const lngShowError As Long = 7001            ' shows error
Public Const lngShowErrorNoLine As Long = 7002      ' shows error without line number
Public Const lngShowWarning As Long = 7003          ' show warning
Public Const lngShowMessage As Long = 7004          ' shows information
Public Const lngShowGlobal As Long = 7005           ' shows global message instead of the error description
Public Const lngShowStatus As Long = 7006           ' shows standard log

' communication between modules
Public lngGlobalErrNumber As Long                   ' pass error numbers from external modules
Public strGlobalErrDescription As String            ' pass error numbers from external modules



' reload data
'   strConfiguration sheet - sheet where commands are pulled from
'   strDBUserPasswordSets - connection parameters sets
Public Sub sRunProgram(strConfigurationSheet, strDBUserPasswordSets)
On Error GoTo Error_Handler

    Call sInitialize
    Set objRSGlobal = CreateObject("ADODB.Recordset")
    Set objFSO = CreateObject("Scripting.FileSystemObject")

    ' initialize for processing
    Set objConfigSheet = ThisWorkbook.Worksheets(strConfigurationSheet)
    intCommandRow = 2
    intCommandRowIncrement = 1              ' proceed 1 step by step
    
    
    ' loop for command and parameters
    Do While objConfigSheet.Cells(intCommandRow, colCommand) <> ""

        ' command and parameter strings have optional parameters, so add delimiters
        ' that way, array references works even if the optional parameters are missing
        arrCommand = Split(objConfigSheet.Cells(intCommandRow, colCommand) & String(3, Chr(10)), Chr(10))
        arrCommand(0) = Clean(arrCommand(0))
        strParameter1 = objConfigSheet.Cells(intCommandRow, colParameter1).Value
        
        
        ' show debug messages if flag is turned on
        If boolDebug Then
            Application.StatusBar = "Row " & intCommandRow & " : Executing " & arrCommand(0)
            If intDebugSeconds > 0 Then
                Sleep (intDebugSeconds)
            End If
        End If
        
        
        ' execute the command
        Select Case (arrCommand(0))
        Case "!clear"
            ' clear range contents
            fGetRange(arrCommand(1)).ClearContents
            fAddLogEntry ("Cleared range [" & arrCommand(1) & "]")

        Case "!convertformulatovalues"
            ' convert the chosen range to values
            With fGetRange(arrCommand(1))
                .Worksheet.AutoFilterMode = False
                
                ' .value = .value will be very slow
                .Copy
                .PasteSpecial xlPasteValues
                
                ' we don't want to leave the range selected, so focus on A1
                ' (hack) select won't work, so use copy and pastespecial-all
                With .Worksheet.Range("A1")
                    .Copy
                    .PasteSpecial xlPasteAll
                End With
            End With
            Application.CutCopyMode = False
            fAddLogEntry ("Converted formulas to values for [" & arrCommand(1) & "]")
            
        Case "!debug"
            boolDebug = True
            If arrCommand(1) <> "" Then
                ' pause for a maximum of 5 seconds between commands
                If arrCommand(1) > 5 Then
                    arrCommand(1) = 5
                End If
                intDebugSeconds = arrCommand(1) * 1000
            End If
            fAddLogEntry ("Debug turned on")
            
        Case "!dummy"
            fAddLogEntry ("Skipped dummy statement")
            
        Case "!extract"
            
            ' putting this first so that invalid addresses errors are filtered out before DB connects
            intStartColumn = 1
            With fGetRange(arrCommand(1))
                Set objWorksheet = .Worksheet
                
                ' specific location or whole worksheet
                boolTargetIsSheet = True
                If InStr(1, arrCommand(1), "!") <> 0 Then
                    boolTargetIsSheet = False
                    intOutputRow = .Row
                    intStartColumn = .Column
                End If
            End With
            
            
            ' start a new extract, or continue adding to the previous resultset
            boolContinueExtract = False
            If Clean(objConfigSheet.Cells(intCommandRow, colCommand).Value) = _
                Clean(objConfigSheet.Cells(intCommandRow - intCommandRowIncrement, colCommand).Value) And _
                boolTargetIsSheet Then
                boolContinueExtract = True
            End If
            
            
            ' get database parameters
            strParameter2 = objConfigSheet.Cells(intCommandRow, colParameter2).Value
            strParameter3 = objConfigSheet.Cells(intCommandRow, colParameter3).Value
            
            ' setup connection based on database type
            boolCopyExists = False
            boolTruncateRequired = False
            Select Case (Clean(arrCommand(2)))
            ' connection string formats from http://www.connectionstrings.com
            Case "access"
                ' handle relative paths
                If Left(strParameter2, 3) = "..\" Or _
                    Left(strParameter2, 2) = ".\" Then
                    strParameter2 = ThisWorkbook.Path & "\" & strParameter2
                End If
                
                strConnString = "Provider=Microsoft.ACE.OLEDB.12.0" & _
                    ";Persist Security Info=False" & _
                    ";Data Source=" & strParameter2

            Case "excel"
                ' handle relative paths
                If Left(strParameter2, 3) = "..\" Or _
                    Left(strParameter2, 2) = ".\" Then
                    strParameter2 = ThisWorkbook.Path & "\" & strParameter2
                End If

                ' if extracting data from same file save a copy and extract from that
                ' workaround for http://support.microsoft.com/kb/319998
                If Clean(objFSO.GetAbsolutePathName(strParameter2)) = Clean(objFSO.GetAbsolutePathName(ThisWorkbook.FullName)) Then
                    Dim strTempPath As String
                    Dim strTempFilePath As String
                    
                    ' get temporary files' path
                    intTempPathLength = GetTempPathA(0, "")
                    strTempPath = Space(intTempPathLength)
                    Call GetTempPathA(intTempPathLength, strTempPath)
                    strTempPath = Left(strTempPath, intTempPathLength - 1)
                    
                    ' get temporary file name
                    strTempFilePath = Space(Len(strTempPath) + 256)
                    Call GetTempFileNameA(strTempPath, "DBR", &H0, strTempFilePath)
                    strTempFilePath = Left$(strTempFilePath, InStr(strTempFilePath, Chr$(0)) - 1)
                    
                    ' copy the current workbook and use that copy as the source
                    ThisWorkbook.SaveCopyAs strTempFilePath
                    strParameter2 = strTempFilePath
                    boolCopyExists = True
                End If
                
                ' set the connection string depending on the file type
                strExtension = Clean(objFSO.getExtensionName(strParameter2))
                If strExtension = "xlsx" Then
                    strConnString = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0 Xml; IMEX=1'"
                ElseIf strExtension = "xlsm" Then
                    strConnString = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0 Macro; IMEX=1'"
                ElseIf strExtension = "xlsb" Then
                    strConnString = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0; IMEX=1'"
                ElseIf strExtension = "xls" Then
                    strConnString = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0; IMEX=1'"
                End If
                strConnString = strConnString & _
                    ";Persist Security Info=False" & _
                    ";Data Source=" & strParameter2

                   
                ' cells with data > 255 characters will be truncated if the detected datatype <> memo
                ' so additionally, in this case we need to clip off characters after 255, as they will be junk
                boolTruncateRequired = fTruncateRequired(strConnString, strParameter1, objRSGlobal, arrCommand(3))

            Case ""
                ' if its a different server and database get connnection parameters
                If strServer <> strParameter2 Or _
                    strDatabase <> strParameter3 Then
                    strServer = strParameter2
                    strDatabase = strParameter3
                    arrConnectionData = Split(fGetUserPassword(strServer, strDatabase, strDBUserPasswordSets), Chr(13))
                End If
                    
                ' set up connnection
                strConnString = "Provider=SQLOLEDB" & _
                    ";Data Source=" & strServer & _
                    ";Initial Catalog=" & strDatabase & _
                    ";UID=" & arrConnectionData(0) & _
                    ";PWD=" & arrConnectionData(1)
            End Select
            
            
            ' get, clean and run query
            objRSGlobal.CursorLocation = 3
            objRSGlobal.Open fCleanQuery(strParameter1), strConnString
            intColumnCount = objRSGlobal.Fields.Count

                        
            With objWorksheet
                ' clean target sheet and add headers
                If boolTargetIsSheet And Not boolContinueExtract Then
                    
                    ' see how many comment columns are there after the end
                    m = intColumnCount
                    Do While Not .Cells(1, m + 1).Comment Is Nothing
                        m = m + 1
                    Loop
                
                    ' remove autofilter and clear header and data area
                    ' including comments area
                    .AutoFilterMode = False
                    .Range("A1:" & Cells(65536, m).Address).ClearContents
                    
                    ' add headers
                    j = 1
                    For Each strField In objRSGlobal.Fields
                        .Cells(1, j).Value = strField.Name
                        j = j + 1
                    Next
                    
                    ' start writing from the 2nd row
                    intOutputRow = 2
                End If


                ' add data
                intStartOutputRow = intOutputRow
                While Not objRSGlobal.EOF
                    For p = 0 To intColumnCount - 1
                        If Not IsNull(objRSGlobal.Fields(p).Value) Then
                            ' performance impact due to check being "in" the loop is negligible
                            If boolTruncateRequired Then
                                .Cells(intOutputRow, intStartColumn + p).Value = Left(objRSGlobal.Fields(p).Value, 255)
                            Else
                                .Cells(intOutputRow, intStartColumn + p).Value = objRSGlobal.Fields(p).Value
                            End If
                        End If
                    Next
                    
                    objRSGlobal.MoveNext
                    intOutputRow = intOutputRow + 1
                Wend

                ' no formula columns for specific address
                ' range function fails if there are no rows
                If boolTargetIsSheet And _
                    intOutputRow > intStartOutputRow Then
                    
                    p = intColumnCount + 1
                    Do While Not .Cells(1, p).Comment Is Nothing
                        
                        ' build a comment data area range
                        strRangeAddress = Cells(intStartOutputRow, p).AddressLocal & _
                            ":" & Cells(intOutputRow - 1, p).AddressLocal
                        
                        With objWorksheet.Range(strRangeAddress)
                            ' set the formula to general to force a formula to evaluate
                            .NumberFormat = "General"
                            .Value = objWorksheet.Cells(1, p).Comment.Text
                            ' just data, like "1", will automatically set the cell format
                            .NumberFormat = "General"
                        End With
                        p = p + 1
                    Loop
                End If
            
            
                ' close
                objRSGlobal.Close
                objRSGlobal.ActiveConnection.Close
                
                ' autofit if required
                If boolAutofit Then
                    .Cells.EntireColumn.AutoFit
                End If
            End With
            
            ' if the import involved creating a copy delete it
            If boolCopyExists Then
                objFSO.DeleteFile strTempFilePath
            End If
            
            ' log success message
            fAddLogEntry ("Data refreshed for [" & arrCommand(1) & "]")
    
        Case "!filter"
            With ThisWorkbook.Worksheets(arrCommand(1))
                .AutoFilterMode = False
            
                ' apply the autofilter
                arrFilters = Split(strParameter1, Chr(10))
                intFilters = UBound(arrFilters)
                For i = 0 To intFilters
                    arrFilterParameters = Split(arrFilters(i), ";")
                    intField = Application.WorksheetFunction.Match(arrFilterParameters(0), .Rows("1:1"), False)
                    .Cells.AutoFilter intField, arrFilterParameters(1)
                Next
            End With

            ' log success message
            fAddLogEntry ("Applied filter for [" & arrCommand(1) & "] worksheet")
        
        Case "!form"
            frmGeneric.sShowGenericForm arrCommand(1), arrCommand(2), strParameter1, boolNoScreenRefresh
            
            ' was there a (handled) error while showing the form?
            If lngGlobalErrNumber <> 0 Then
                Err.Raise lngGlobalErrNumber, , strGlobalErrDescription
            End If
            fAddLogEntry ("Loaded form [" & Split(arrCommand(1), ":")(0) & "]")
        
        Case "!ontruemove"
            ' intCommandRow is used by !Extract for "continuing" an extract, so
            ' intCommandRow - intCommandRowIncrement must point to a 'real' command,
            ' not another !ontruemove
            If fGetRange(arrCommand(1)).Value = True Then
                intCommandRow = intCommandRow - intCommandRowIncrement
                intCommandRowIncrement = intCommandRowIncrement + arrCommand(2)
                fAddLogEntry ("Moved command " & arrCommand(2) & " row(s)")
            Else
                intCommandRow = intCommandRow - intCommandRowIncrement
                intCommandRowIncrement = intCommandRowIncrement + 1
            End If
            
        Case "!msgbox"
            fGetRange(arrCommand(2)).Value = (fMsgBox(arrCommand(1), vbYesNo) = vbYes)
            fAddLogEntry ("Got Yes / No value")
        
        Case "!refreshpivots"
            ' refresh pivot tables in Pivot sheet
            For Each pTable In ThisWorkbook.Worksheets(arrCommand(1)).PivotTables
                pTable.RefreshTable
            Next pTable
            fAddLogEntry ("Refreshed pivot tables for [" & arrCommand(1) & "]")
        
        Case "!run"
            ' functions will have an extra line
            If arrCommand(2) = "" Then
                Application.Run arrCommand(1) & "Wrapper", strParameter1
            Else
                fGetRange(arrCommand(2)).Value = Application.Run(arrCommand(1) & "Wrapper", strParameter1)
            End If
            
            ' was there an error while running the subroutine / function?
            If lngGlobalErrNumber <> 0 Then
                Err.Raise lngGlobalErrNumber, , strGlobalErrDescription
            End If
            
            ' repaint the screen and turn off calculation again (unless screen updates is off)
            ' we don't trust external modules to do the right thing always
            If Not boolNoScreenRefresh Then
                Application.ScreenUpdating = True
                Application.ScreenUpdating = False
            End If
            Application.Calculation = xlCalculationManual
            
            fAddLogEntry ("Ran routine [" & arrCommand(1) & "]")
        
        Case "!set"
            ' find which configuration variable and set it
            boolIsCell = False
            Select Case (Clean(arrCommand(1)))
            Case "autofit"
                boolAutofit = Clean(strParameter1)
            
            Case "no screen refresh"
                boolNoScreenRefresh = strParameter1
                
            Case "run timestamp address"
                ' if the sheet name is within quotes and there is no extra starting quote excel uses up the first ' at the start to format the value as a string
                If InStr(1, strParameter1, "'!") And _
                    Left(Clean(strParameter1), 1) <> "'" Then
                    strParameter1 = "'" & Clean(strParameter1)
                End If
                
                strLastUpdatedAddress = strParameter1
            
            Case "run message"
                strUserMessage = strParameter1
                
            ' set a value of a cell
            Case Else
                fGetRange(arrCommand(1)).Value = strParameter1
                boolIsCell = True
            End Select
            
            ' log message
            If Not boolIsCell Then
                fAddLogEntry ("Set configuration variable [" & arrCommand(1) & "]")
            Else
                fAddLogEntry ("Set cell [" & arrCommand(1) & "]")
            End If
        
        Case "!stopifblank"
            If Application.WorksheetFunction.CountBlank(fGetRange(arrCommand(1))) Then
                
                ' if there is no message in script
                If arrCommand(2) = "" Then
                    arrCommand(2) = "Row " & intCommandRow & " : Validation failed for [" & arrCommand(1) & "]"
                End If
                
                ' show the message and exit
                Err.Raise lngShowMessage, , arrCommand(2)
            End If
            fAddLogEntry ("Validation passed for [" & arrCommand(1) & "]")
            
        Case "!version"
            ' show the version information
            strVersion = "Version v7.7" & vbCrLf & vbCrLf & _
                "ExcelBricks API v6.2+" & vbCrLf & _
                "ExcelBricks Syntax v7.7+     "
            fMsgBox strVersion, vbInformation, "Version"
            fAddLogEntry ("Displayed version information")
        
        Case Else
            ' stop on an unrecognized keyword
            Err.Raise lngFullError, , "Unrecognized command"
            
        End Select
        
        
        ' run a manual calculation - to account for formulas in configuration sheet
        Application.MaxChange = 0.001
        ThisWorkbook.PrecisionAsDisplayed = False
        Application.Calculate
        
        ' reset step size
        If arrCommand(0) <> "!ontruemove" Then
            intCommandRowIncrement = 1
        End If
        
        ' move to the next row (add skip if applicable)
        intCommandRow = intCommandRow + intCommandRowIncrement
    Loop
    
    
    ' update last updated date-time
    If strLastUpdatedAddress <> "" Then
        fGetRange(strLastUpdatedAddress).Value = Now()
    End If
    

Error_Handler:
    ' store error if any
    lngGlobalErrNumber = Err.Number
    ' workaround for displaying the message properly for a form / text-password close
    ' required because closing a form and raising an error overwrites the err.description on return
    strGlobalErrDescription_Old = strGlobalErrDescription
    strGlobalErrDescription = Err.Description


    ' cleanup
    On Error Resume Next
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    ' clear status bar only if it was used for debug
    If boolDebug Then Application.StatusBar = False
    
    Call frmTextPassword.sClearRetainFlag
    
    Set objWorksheet = Nothing
    Set objConfigSheet = Nothing
    
    If Not IsEmpty(objRSGlobal) Then
        If Not objRSGlobal Is Nothing Then
            ' check if the recordset is open
            If objRSGlobal.State <> 0 Then
                objRSGlobal.Close
            End If
            
            ' a type name check is better than an IsEmpty check since
            ' the connection could be null, a string or Nothing too
            If TypeName(objRSGlobal.ActiveConnection) = "Connection" Then
                ' check if the connection is open
                If objRSGlobal.ActiveConnection.State <> 0 Then
                    objRSGlobal.ActiveConnection.Close
                End If
            End If
        End If
    End If
    Set objRSGlobal = Nothing
    
    ' required because the shared workbook check preceeds the FSO creation
    If Not IsEmpty(objFSO) Then
        ' check if the temporary file exists
        If objFSO.FileExists(strTempFilePath) Then
            objFSO.Delete strTempFilePath
        End If
    End If
    
    Set objFSO = Nothing


    ' show status message
    If lngGlobalErrNumber = 0 And strUserMessage <> "" And strUserMessage <> "!blank" Then
        MsgBox strUserMessage, vbInformation, "Run Complete"
    ' show message unless it's one of those that don't need a status message
    ElseIf lngGlobalErrNumber <> lngShowError And lngGlobalErrNumber <> lngShowErrorNoLine And _
        lngGlobalErrNumber <> lngShowMessage And lngGlobalErrNumber <> lngShowGlobal And _
        lngGlobalErrNumber <> lngShowWarning And strUserMessage <> "!blank" Then
            
        ' avoid the extra blank line if the failure is on the first row
        If strStatusLog = "" Then
            fAddLogEntry ("Run time : " & fGetTime() & " seconds")
        Else
            fAddLogEntry (vbCrLf & "Run time : " & fGetTime() & " seconds")
        End If
        
        MsgBox Trim(strStatusLog), vbInformation, "Run Status"
    End If
    
    ' show messages
    If lngGlobalErrNumber = lngShowMessage Then
        MsgBox strGlobalErrDescription, vbInformation, "Run Message"
    ElseIf lngGlobalErrNumber = lngShowGlobal Then
        MsgBox strGlobalErrDescription_Old, vbInformation, "Run Message"
    ElseIf lngGlobalErrNumber = lngShowWarning Then
        MsgBox strGlobalErrDescription, vbExclamation, "Run Warning"
    ElseIf lngGlobalErrNumber = lngShowErrorNoLine Then
        MsgBox strGlobalErrDescription, vbCritical, "Run Error"
    ElseIf lngGlobalErrNumber <> 0 And lngGlobalErrNumber <> lngShowStatus Then
        MsgBox "Row " & intCommandRow & " : " & strGlobalErrDescription, vbCritical, "Run Error"
    End If
    
    On Error GoTo 0
End Sub



' ExcelBricks helper functions

' initialization
Private Sub sInitialize()
    ' start clock
    Call sStartClock

    ' does not run properly on shared workbooks
    If ThisWorkbook.MultiUserEditing Then
        Err.Raise lngShowErrorNoLine, , "This program does not work on shared workbooks"
    End If
    
    ' speed up
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    
    ' initialize global variables
    strStatusLog = ""
    lngGlobalErrNumber = 0
    strGlobalErrDescription = ""
End Sub


' clean queries to run in MS SQL server
Private Function fCleanQuery(strQuery)
    ' enter characters and quotes
    strQuery = Replace(strQuery, Chr(10), " ")
    strQuery = Replace(strQuery, Chr(13), " ")
    strQuery = Replace(strQuery, """", "'")

    fCleanQuery = strQuery
End Function



' Clock functions

' starts clock
Public Sub sStartClock()
    tmStartTime = Now()
End Sub


' stops clock and returns interval in seconds
Public Function fGetTime() As Integer
    fGetTime = DateDiff("s", tmStartTime, Now())
End Function


' pause the clock
Public Sub sPauseClock()
    tmStopClockTime = Now()
End Sub


' continue after a pause
Public Sub sContinueClock()
    ' move start time ahead by paused time
    intSecondsPaused = DateDiff("s", tmStopClockTime, Now())
    tmStartTime = DateAdd("s", intSecondsPaused, tmStartTime)
End Sub



' get the range from an address
Public Function fGetRange(ByVal strAddress) As Range
    strAddress = Trim(strAddress)
    
    ' if this does not refer to a range take all rows
    If InStr(1, strAddress, "!") = 0 Then
        strAddress = "'" & strAddress & "'!1:65536"
    End If
    
    ' replace relative references by actual row numbers
    Set revRelativeRow = CreateObject("VBScript.RegExp")
    With revRelativeRow
        .Pattern = "\[r[^\]]*\]"
        .Global = True
    End With
    
    Set strPhrases = revRelativeRow.Execute(strAddress)
    For Each strPhrase In strPhrases
        strPhraseValue = Evaluate(Mid(Replace(strPhrase, "r", intCommandRow), 2, Len(Replace(strPhrase, "r", intCommandRow)) - 2) & "+0")
        strAddress = Replace(strAddress, strPhrase, strPhraseValue)
    Next
    
    Set revRelativeRow = Nothing
    
    ' return a range object
    With Application.Range(strAddress)
        ' ensure that we are using the current workbook
        Set fGetRange = ThisWorkbook.Worksheets(.Worksheet.Name).Range(.AddressLocal)
    End With
End Function


' convert a cell to a range containing all non 0 cells below
Public Function fGetRangeFromCell(strStartAddress) As Range
    With fGetRange(strStartAddress)
        strWorksheet = .Worksheet.Name
        intRow = .Row
    
        ' need to get worksheet reference in the context of the current workbook
        ' this avoids referencing the wrong sheet when multiple workbooks are open
        Do While ThisWorkbook.Worksheets(strWorksheet).Cells(intRow + 1, .Column) <> ""
            intRow = intRow + 1
        Loop
        Set fGetRangeFromCell = ThisWorkbook.Worksheets(strWorksheet).Range(.AddressLocal & ":" & _
            .Cells(intRow - .Row + 1, 1).AddressLocal)
    End With
End Function


' add a log entry
Public Function fAddLogEntry(strLogEntry)
    strStatusLog = strStatusLog & strLogEntry & vbCrLf
End Function


' clean a string
Private Function Clean(strInput)
    Clean = Trim(LCase(strInput))
End Function


' check if strQuery truncates data for strConnString
Private Function fTruncateRequired(strConnString, strQuery, objRSGlobal, strIgnore)

    objRSGlobal.Open fCleanQuery(strQuery), strConnString
    
    ' build an outer max(len(<column>)) query
    strOuterSelect = ""
    For Each strField In objRSGlobal.Fields
        strOuterSelect = strOuterSelect & ",max(len([" & strField.Name & "]))"
    Next
    objRSGlobal.Close
    strOuterSelect = "select " & Mid(strOuterSelect, 2)
    strMemoCheckQuery = strOuterSelect & " from (" & strQuery & ")"
    
    On Error Resume Next
    ' a memo field would cause an error here
    objRSGlobal.Open strMemoCheckQuery, strConnString
    If Err.Number Then
        On Error GoTo 0
        fTruncateRequired = True

        ' to show or not to show, the message
        If Clean(strIgnore) <> "ignore" Then
            boolIgnoreMemo = fMsgBox("Data with more than 255 characters will be clipped off." & vbCrLf & _
                "Do you want to continue?", vbYesNo, "Data truncation")
            
            If boolIgnoreMemo <> vbYes Then
                Err.Raise lngShowWarning, , "Row " & intCommandRow & " : Source excel has cells with more than 255 characters."
            End If
        End If
    Else
        On Error GoTo 0
        fTruncateRequired = False
        objRSGlobal.Close
    End If

End Function


' get username and password given server and database
Function fGetUserPassword(strServer, strDatabase, strDBUserPasswordSets)

    Set revServerDatabase = CreateObject("VBScript.RegExp")
    revServerDatabase.Global = True
    
    arrDBUserPasswordSets = Split(strDBUserPasswordSets, ";")
    strTestString = Clean(strServer & "." & strDatabase)
    
    ' loop through all sets and return any matches
    For Each i In arrDBUserPasswordSets
        arrConnParameters = Split(i, ":")
        revServerDatabase.Pattern = Replace(Replace(Replace(Clean(arrConnParameters(0)), "\", "\\"), ".", "\."), "*", ".*")
        
        If revServerDatabase.Test(strTestString) Then
            fGetUserPassword = arrConnParameters(1) & Chr(13) & arrConnParameters(2)
            Exit Function
        End If
    Next
    
    Set revServerDatabase = Nothing

    ' if not found prompt for password
    fGetUserPassword = frmTextPassword.fGetTextPassword(strServer & "." & strDatabase, True, boolNoScreenRefresh)
End Function


' standard message box function, but enables screen updates
' works around the "solitaire game winning cascade" display :-)
Function fMsgBox(strPrompt, intButtons, Optional strTitle)
    If Not boolNoScreenRefresh Then
        Application.ScreenUpdating = True
    End If
    If IsMissing(strTitle) Then
        fMsgBox = MsgBox(strPrompt, intButtons)
    Else
        fMsgBox = MsgBox(strPrompt, intButtons, strTitle)
    End If
    Application.ScreenUpdating = False
End Function

